home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch7 / Resize2.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-06-13  |  9.9 KB  |  270 lines
  1. VERSION 5.00
  2. Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
  3. Begin VB.Form frmResize2 
  4.    Caption         =   "Resize2 []"
  5.    ClientHeight    =   2895
  6.    ClientLeft      =   165
  7.    ClientTop       =   735
  8.    ClientWidth     =   3120
  9.    LinkTopic       =   "Form2"
  10.    ScaleHeight     =   2895
  11.    ScaleWidth      =   3120
  12.    StartUpPosition =   3  'Windows Default
  13.    Begin VB.PictureBox picResult 
  14.       Height          =   2295
  15.       Left            =   840
  16.       ScaleHeight     =   149
  17.       ScaleMode       =   3  'Pixel
  18.       ScaleWidth      =   157
  19.       TabIndex        =   4
  20.       Top             =   1440
  21.       Visible         =   0   'False
  22.       Width           =   2415
  23.    End
  24.    Begin VB.CommandButton cmdResize 
  25.       Caption         =   "Resize"
  26.       Default         =   -1  'True
  27.       Height          =   375
  28.       Left            =   1200
  29.       TabIndex        =   3
  30.       Top             =   0
  31.       Width           =   855
  32.    End
  33.    Begin VB.TextBox txtScale 
  34.       Height          =   285
  35.       Left            =   600
  36.       TabIndex        =   2
  37.       Text            =   "1.0"
  38.       Top             =   60
  39.       Width           =   495
  40.    End
  41.    Begin MSComDlg.CommonDialog dlgOpenFile 
  42.       Left            =   0
  43.       Top             =   360
  44.       _ExtentX        =   847
  45.       _ExtentY        =   847
  46.       _Version        =   393216
  47.    End
  48.    Begin VB.PictureBox picOriginal 
  49.       AutoSize        =   -1  'True
  50.       Height          =   2295
  51.       Left            =   120
  52.       ScaleHeight     =   149
  53.       ScaleMode       =   3  'Pixel
  54.       ScaleWidth      =   157
  55.       TabIndex        =   0
  56.       Top             =   480
  57.       Width           =   2415
  58.    End
  59.    Begin VB.Label Label1 
  60.       Caption         =   "Scale"
  61.       Height          =   255
  62.       Left            =   120
  63.       TabIndex        =   1
  64.       Top             =   60
  65.       Width           =   495
  66.    End
  67.    Begin VB.Menu mnuFile 
  68.       Caption         =   "&File"
  69.       Begin VB.Menu mnuFileOpen 
  70.          Caption         =   "&Open..."
  71.          Shortcut        =   ^O
  72.       End
  73.       Begin VB.Menu mnuFileSaveAs 
  74.          Caption         =   "Save &As..."
  75.          Shortcut        =   ^A
  76.       End
  77.    End
  78. Attribute VB_Name = "frmResize2"
  79. Attribute VB_GlobalNameSpace = False
  80. Attribute VB_Creatable = False
  81. Attribute VB_PredeclaredId = True
  82. Attribute VB_Exposed = False
  83. Option Explicit
  84. Private FileName As String
  85. Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
  86. Private Const LR_LOADFROMFILE = &H10
  87. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  88. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  89. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  90. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  91. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  92. Private Const SRCCOPY = &HCC0020
  93. ' Arrange the controls.
  94. Private Sub ArrangeControls(ByVal scale_factor As Single)
  95. Dim new_wid As Single
  96. Dim new_hgt As Single
  97.     ' Calculate the result's size.
  98.     new_wid = picOriginal.ScaleWidth * scale_factor
  99.     new_hgt = picOriginal.ScaleHeight * scale_factor
  100.     new_wid = ScaleX(new_wid, vbPixels, ScaleMode) + picOriginal.Width - ScaleX(picOriginal.ScaleWidth, vbPixels, ScaleMode)
  101.     new_hgt = ScaleY(new_hgt, vbPixels, ScaleMode) + picOriginal.Height - ScaleY(picOriginal.ScaleHeight, vbPixels, ScaleMode)
  102.     ' Position the result PictureBox.
  103.     picResult.Move _
  104.         picOriginal.Left + picOriginal.Width + 120, _
  105.         picOriginal.Top, new_wid, new_hgt
  106.     picResult.Line (0, 0)-(picResult.ScaleWidth, picResult.ScaleHeight), _
  107.         picResult.BackColor, BF
  108.     picResult.Picture = picResult.Image
  109.     picResult.Visible = True
  110.     ' This makes the image resize itself to
  111.     ' fit the picture.
  112.     picResult.Picture = picResult.Image
  113.     ' Make the form big enough.
  114.     new_wid = picResult.Left + picResult.Width
  115.     If new_wid < cmdResize.Left + cmdResize.Width _
  116.         Then new_wid = cmdResize.Left + cmdResize.Width
  117.     new_hgt = picResult.Top + picResult.Height
  118.     If new_hgt < picOriginal.Top + picOriginal.Height _
  119.         Then new_hgt = picOriginal.Top + picOriginal.Height
  120.     Move Left, Top, new_wid + 237, new_hgt + 816
  121.     DoEvents
  122. End Sub
  123. ' Use the LoadImage API function to load a picture
  124. ' from a file into a PictureBox, filling the PictureBox.
  125. Private Sub LoadImageFromFile(ByVal file_name As String, ByVal pic As PictureBox)
  126. Dim wid As Long
  127. Dim hgt As Long
  128. Dim mem_dc As Long
  129. Dim hbmp As Long
  130.     ' Get the desired size in pixels.
  131.     wid = pic.ScaleX(pic.ScaleWidth, pic.ScaleMode, vbPixels)
  132.     hgt = pic.ScaleY(pic.ScaleHeight, pic.ScaleMode, vbPixels)
  133.     ' Get the bitmap handle from the file.
  134.     hbmp = LoadImage(ByVal 0&, file_name, 0, _
  135.         wid, hgt, LR_LOADFROMFILE)
  136.     ' Create a device context to hold the image.
  137.     mem_dc = CreateCompatibleDC(0)
  138.     ' Select the bitmap into the device context.
  139.     SelectObject mem_dc, hbmp
  140.     ' Copy the bitmap into picResult.
  141.     BitBlt pic.hdc, 0, 0, wid, hgt, _
  142.         mem_dc, 0, 0, SRCCOPY
  143.     pic.Refresh
  144.     ' Delete the device context and bitmap.
  145.     DeleteDC mem_dc
  146.     DeleteObject hbmp
  147. End Sub
  148. ' Transform the picture.
  149. Private Sub cmdResize_Click()
  150. Dim scale_factor As Single
  151.     ' Do nothing if no picture is loaded.
  152.     If picOriginal.Picture = 0 Then Exit Sub
  153.     ' Get the scale.
  154.     On Error GoTo ScaleError
  155.     scale_factor = CSng(txtScale.Text)
  156.     On Error GoTo 0
  157.     Screen.MousePointer = vbHourglass
  158.     picResult.Line (0, 0)-(picResult.ScaleWidth, picResult.ScaleHeight), _
  159.         picResult.BackColor, BF
  160.     DoEvents
  161.     ' Arrange picResult.
  162.     ArrangeControls scale_factor
  163.     ' Reload the picture using LoadImage.
  164.     LoadImageFromFile FileName, picResult
  165.     Screen.MousePointer = vbDefault
  166.     Exit Sub
  167. ScaleError:
  168.     MsgBox "Invalid scale"
  169.     txtScale.SetFocus
  170. End Sub
  171. ' Start in the current directory.
  172. Private Sub Form_Load()
  173.     picOriginal.AutoSize = True
  174.     picOriginal.ScaleMode = vbPixels
  175.     picOriginal.AutoRedraw = True
  176.     picResult.ScaleMode = vbPixels
  177.     picResult.AutoRedraw = True
  178.     dlgOpenFile.CancelError = True
  179.     dlgOpenFile.InitDir = App.Path
  180.     dlgOpenFile.Filter = _
  181.         "Bitmaps (*.bmp)|*.bmp|" & _
  182.         "GIFs (*.gif)|*.gif|" & _
  183.         "JPEGs (*.jpg)|*.jpg;*.jpeg|" & _
  184.         "Icons (*.ico)|*.ico|" & _
  185.         "Cursors (*.cur)|*.cur|" & _
  186.         "Run-Length Encoded (*.rle)|*.rle|" & _
  187.         "Metafiles (*.wmf)|*.wmf|" & _
  188.         "Enhanced Metafiles (*.emf)|*.emf|" & _
  189.         "Graphic Files|*.bmp;*.gif;*.jpg;*.jpeg;*.ico;*.cur;*.rle;*.wmf;*.emf|" & _
  190.         "All Files (*.*)|*.*"
  191.     Width = picResult.Left + picResult.Width + 120 + Width - ScaleWidth
  192.     Height = picOriginal.Top + picOriginal.Height + 120 + Height - ScaleHeight
  193. End Sub
  194. ' Load the indicated file.
  195. Private Sub mnuFileOpen_Click()
  196. Dim file_name As String
  197.     ' Let the user select a file.
  198.     On Error Resume Next
  199.     dlgOpenFile.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  200.     dlgOpenFile.ShowOpen
  201.     If Err.Number = cdlCancel Then
  202.         Exit Sub
  203.     ElseIf Err.Number <> 0 Then
  204.         Beep
  205.         MsgBox "Error selecting file.", , vbExclamation
  206.         Exit Sub
  207.     End If
  208.     On Error GoTo 0
  209.     Screen.MousePointer = vbHourglass
  210.     DoEvents
  211.     file_name = Trim$(dlgOpenFile.FileName)
  212.     dlgOpenFile.InitDir = Left$(file_name, Len(file_name) _
  213.         - Len(dlgOpenFile.FileTitle) - 1)
  214.     Caption = "Resize [" & dlgOpenFile.FileTitle & "]"
  215.     ' Save the file name for use with LoadImage.
  216.     FileName = file_name
  217.     ' Open the original file.
  218.     On Error GoTo LoadError
  219.     picOriginal.Picture = LoadPicture(file_name)
  220.     On Error GoTo 0
  221.     ' Hide picResult.
  222.     picResult.Visible = False
  223.     If cmdResize.Left + cmdResize.Width > picOriginal.Left + picOriginal.Width Then
  224.         Width = cmdResize.Left + cmdResize.Width + 120 + Width - ScaleWidth
  225.     Else
  226.         Width = picOriginal.Left + picOriginal.Width + 120 + Width - ScaleWidth
  227.     End If
  228.     Height = picOriginal.Top + picOriginal.Height + 120 + Height - ScaleHeight
  229.     Screen.MousePointer = vbDefault
  230.     Exit Sub
  231. LoadError:
  232.     Screen.MousePointer = vbDefault
  233.     MsgBox "Error " & Format$(Err.Number) & _
  234.         " opening file '" & file_name & "'" & vbCrLf & _
  235.         Err.Description
  236. End Sub
  237. ' Save the transformed image.
  238. Private Sub mnuFileSaveAs_Click()
  239. Dim file_name As String
  240.     ' Let the user select a file.
  241.     On Error Resume Next
  242.     dlgOpenFile.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
  243.     dlgOpenFile.ShowSave
  244.     If Err.Number = cdlCancel Then
  245.         Exit Sub
  246.     ElseIf Err.Number <> 0 Then
  247.         Beep
  248.         MsgBox "Error selecting file.", , vbExclamation
  249.         Exit Sub
  250.     End If
  251.     On Error GoTo 0
  252.     Screen.MousePointer = vbHourglass
  253.     DoEvents
  254.     file_name = Trim$(dlgOpenFile.FileName)
  255.     dlgOpenFile.InitDir = Left$(file_name, Len(file_name) _
  256.         - Len(dlgOpenFile.FileTitle) - 1)
  257.     Caption = "Resize [" & dlgOpenFile.FileTitle & "]"
  258.     ' Save the transformed image into the file.
  259.     On Error GoTo SaveError
  260.     SavePicture picResult.Picture, file_name
  261.     On Error GoTo 0
  262.     Screen.MousePointer = vbDefault
  263.     Exit Sub
  264. SaveError:
  265.     Screen.MousePointer = vbDefault
  266.     MsgBox "Error " & Format$(Err.Number) & _
  267.         " saving file '" & file_name & "'" & vbCrLf & _
  268.         Err.Description
  269. End Sub
  270.